home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / MATH / MATH2 / UTIL.PAS < prev   
Pascal/Delphi Source File  |  1985-05-17  |  58KB  |  1,654 lines
  1. {****************************************************************************
  2.  *  This Module Comprises the various utility routines used by the other    *
  3.  * modules in the program.  Routines included in this module are:           *
  4.  *                                                                          *
  5.  *         Routine                   Use                                    *
  6.  *  *  1   Upper_Left_X      Returns the left x coordinate of active window *
  7.  *  *  2   Upper_Left_Y      Returns the upper y coord of active window     *
  8.  *  *  3   Lower_Right_X     Returns the right x coord of active window     *
  9.  *  *  4   Lower_Right_Y     Returns the lower y coord of active window     *
  10.  *  *  5   RvsOn             Turns on Reverse Video                         *
  11.  *  *  6   RvsOff            Turns off Reverse Video                        *
  12.  *     7   Yes               Prints a prompt, if user inputs 'Y' returns    *
  13.  *                           Trues, otherwise returns False                 *
  14.  *  *  8   Click             Produces a single click from the PC speaker    *
  15.  *  *  9   Alert             Prints a message to the screen and makes noise *
  16.  *  * 10   Beep              Makes noise for a specified period of time     *
  17.  *    11   Replicate         Duplicates a character a specified no. of times*
  18.  *    12   Left              Left justifys a string in a field of spaces    *
  19.  *    13   Center            Centers a string in a field of specified width *
  20.  *    14   Get_Payment_Amount Calculates a loan payment amount              *
  21.  *    15   Write_Neatly      Outputs numbers with commas                    *
  22.  *    16   Get_Str           Writes a string to the screen, allows it to be *
  23.  *                           edited and returns the terminating character   *
  24.  *    17   Get_Num           Does for numbers what Get_Str does for strings *
  25.  *  * 18   Frame             Frames a specified portion of the screen       *
  26.  *  * 19   UnFrame           Removes the frame from the screen              *
  27.  *  * 20   Menu              Displays a menu and gets a user input          *
  28.  *  * 21   Clear_Window      Clears the screen within a window              *
  29.  *  * 22   Window_Frame      Sets up, frames and titles a screen window     *
  30.  *    23   Encrypt           Encrypts a string using XOR                    *
  31.  *    24   Decrypt           Decrypts a string encrypted by encrypt         *
  32.  *    25   GetChar           Gets a character from the keyboard             *
  33.  *    26   Wait              Waits for a KeyPressed                         *
  34.  *    27   Get_Pass          Gets a password from the user                  *
  35.  *  * 28   Push_Screen       Saves the current screen                       *
  36.  *  * 29   Pop_Screen        Restores a saved screen                        *
  37.  *    30   Inc               Increments an integer by 1                     *
  38.  *    31   Dec               Decrements an integer by 1                     *
  39.  *  * 32   Setup             Sets the IBM Serial Interface                  *
  40.  *    34   Upper             Convert String to Upper Case                   *
  41.  *    35   Lower             Convert String to Lower Case                   *
  42.  *  * 36   DosConOut         Usr Device Driver.  Calls DOS Video Output     *
  43.  *  * 37   SerialIn          Aux Device Driver.  Serial port input          *
  44.  *  * 38   SerialOut         Aux Device Driver.  Serial port output         *
  45.  *    39   Power             Raises a number to a power                     *
  46.  *  * 40   Data              Returns true if there is data at the RS232     *
  47.  *  * 41   ColScr            Switch to color monitor if there               *
  48.  *  * 42   MonoScr           Switch to Monochrome monitor if there          *
  49.  *  * 43   Marquee           Display Marquee and put message in it          *
  50.  *  * 44   Help              Displays an appropriate help screen            *
  51.  *  * 45   Well              Expresses impatience                           *
  52.  *  * 47   Siren             makes a sound like a siren                     *
  53.  *  * 48   GetForm           generalized input routine                      *
  54.  *  * 49   Date              gets the date from the system                  *
  55.  *  * 50   Time              gets time from system                          *
  56.  *  * 51   Push_Window       pushes a small section of the screen           *
  57.  *  * 52   Elapsed_time      the time in seconds from the argument          *
  58.  *                                                                          *
  59.  *  * Indicates that the routine has IBM PC specific sections and would need*
  60.  *    to be modified for other computers                                    *
  61.  ****************************************************************************}
  62.  
  63. Procedure HighVideo;
  64.  
  65. Begin
  66.   TextColor(White);
  67.   TextBackground(Black);
  68. End;
  69.  
  70. Procedure NormVideo;
  71.  
  72. Begin
  73.   TextColor(White);
  74.   TextBackground(Black);
  75. End;
  76.  
  77. Procedure LowVideo;
  78.  
  79. Begin
  80.   TextColor(LightGray);
  81.   TextBackground(Black);
  82. End;
  83.  
  84. Type
  85.   Parity_Types = (Odd_Parity, Even_Parity, No_Parity);
  86.   Reg          = Record
  87.     AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
  88.   End;
  89.  
  90. Const
  91.   COM1  =  1016;  {Com1 and Com2 Base port address}
  92.   DLL   =   0;    {LSB of Divisor Latch, Offset 0, R/W}
  93.   DLM   =   1;    {MSB of Divisor Latch, Offset 1, R/W}
  94.   LCR   =   3;    {Line Control Register, Offset 3, R/W}
  95.   MCR   =   4;    {Modem Control Register, Offset 4, R/W}
  96.   LSR   =   5;    {Line Status Register, Offset 5, RO}
  97.   MSR   =   6;    {Modem Status Register, Offset 6, RO}
  98.   MRR   =   7;    {Modem Rate Register, Offset 7, RO, (1200B Hayes only)}
  99.   DLAB  =   128;  {Data Latch Access Bit, High to access DLL and DLM}
  100.   SBRK  =   64;   {Set Break, High to transmit a break signal}
  101.   STPTY =   32;   {Stick Parity, If high parity bit follows EPS}
  102.   EPS   =   16;   {Select Even Parity, High for Even parity}
  103.   PEN   =   8;    {Parity Enable, High to enable parity checking}
  104.   STB   =   4;    {Stop Bits, High for 2 stop bits (1.5 for 5 bit word)
  105.                    low for 1 stop bit}
  106.   WLS   =   3;    {Select Number of bits per word as follows:
  107.                     Bit 1            Bit 2     Word Length
  108.                       0                0         5 Bits
  109.                       0                1         6 Bits
  110.                       1                0         7 Bits
  111.                       1                1         8 Bits}
  112.   LOOP  =   16;   {Enable loop back for testing}
  113.   OUT2  =   8;    {Enable interrupt line drivers if high}
  114.   OUT1  =   4;    {Reset Smartmodem 1200B}
  115.   RTS   =   2;    {Request to send follows this bit}
  116.   DTR   =   1;    {Data Terminal Ready follows this bit inversely, required
  117.                    for modem operation}
  118.  
  119. {****************************************************************************}
  120. Function Upper_Left_X : Integer;       {* These four routines allow a       *}
  121. {1*}                                   {* routine to adjust its output      *}
  122. Begin                                  {* according to what size window it  *}
  123.   Upper_Left_X := Mem[Dseg:$156] + 1;  {* is operating in.  They are        *}
  124. End;                                   {* compatible only with Turbo Pascal *}
  125.                                        {* version 2.0 on an IBM PC or       *}
  126. Function Upper_Left_Y : Integer;       {* compatible                        *}
  127. {2*}
  128. Begin
  129.   Upper_Left_Y := Mem[Dseg:$157] + 1;
  130. End;
  131.  
  132. Var
  133. {3*}
  134.   Lower_Right_X : Byte Absolute Cseg:$16A;
  135. {4*}
  136.   Lower_Right_Y : Byte Absolute Cseg:$16B;
  137.  
  138. {****************************************************************************}
  139. Procedure RvsOn;                       {*  These two routines turn on and   *}
  140. {5*}                                   {*  off Reverse video on the IBM PC  *}
  141. Begin                                  {*************************************}
  142.   TextColor(0);
  143.   TextBackGround(7);
  144. End;
  145.  
  146. Procedure RvsOff;
  147. {6*}
  148. Begin
  149.   LowVideo;
  150. End;
  151.  
  152. {30**************************************************************************}
  153. Procedure Inc(                     {* Increment argument by One             *}
  154.           Var I : Integer);        {*****************************************}
  155.  
  156. Begin
  157.   I := I + 1;
  158. End;
  159.  
  160. {31**************************************************************************}
  161. Procedure Dec(                     {* Decrement argument by One             *}
  162.           Var I : Integer);        {*****************************************}
  163.  
  164. Begin
  165.   I := I - 1;
  166. End;
  167.  
  168. {26**************************************************************************}
  169. Procedure Wait;                       {* Wait for a keypress from the KBD   *}
  170.                                       {**************************************}
  171. Var
  172.   AnyKey : Char;
  173.  
  174. Begin
  175.   Read(Kbd,AnyKey);
  176. End;
  177.  
  178. {****************************************************************************}
  179. Type                                   {* Just a couple of type declarations*}
  180.   Menu_Item       = String[40];        {* needed for a number of routines   *}
  181.                                        {*************************************}
  182.   Menu_Selections = Array[1..15] of Menu_Item;
  183.   Long_String     = String[255];
  184.   Register        = Record
  185.                     AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
  186.                     End;
  187.   ScreenLoc       = Record
  188.     Ch            : Char;
  189.     Attrib        : Byte;
  190.   End;
  191.   Video           = Array[1..25] of Array[1..80] of ScreenLoc;
  192.   Video_Ptr       = ^Video_Stack;
  193.   vidscr          = array[1..1] of screenloc;
  194.   Video_Stack     = Record
  195.                     Next_Screen  : Video_Ptr;
  196.                     x1,y1,
  197.                     x2,y2        : byte;
  198.                     Screen_store : ^vidscr;
  199.                     End;
  200.  
  201. Var
  202.   ScreenBuffer  : Video;
  203.   Screen_Stack  : Video_Ptr;
  204.   Screen        : ^Video;
  205.   Com           : Integer;
  206.   HelpContext   : Integer;
  207.   ScreenFile    : File of Video;
  208.  
  209. {7***************************************************************************}
  210. Function Yes(Prompt : Long_String) : Boolean;{* This routine prints PROMPT  *}
  211.                                              {* to the screen and waits for *}
  212. Var                                          {* the user to type either a   *}
  213.   Inchar : Char;                             {* 'y' or 'n'.  It is case     *}
  214.                                              {* insensitive.  If a 'y' is   *}
  215. Begin                                        {* entered, the function       *}
  216.   Write(Prompt);                             {* returns TRUE.               *}
  217.   Repeat                                     {*******************************}
  218.     Read(Kbd,Inchar);
  219.   Until Inchar in ['Y','y','N','n'];
  220.   Write(Inchar);
  221.   Yes := Inchar in ['Y','y'];
  222. End;
  223.  
  224. {34**************************************************************************}
  225. Function Upper (S : Long_String)       {* Convert Strng S to Upper case     *}
  226.                : Long_String;          {* Return uppercase string           *}
  227.                                        {*************************************}
  228. Var
  229.   I : Integer;
  230.   lcase : Set of Char;
  231.  
  232. Begin
  233.   lcase := ['a'..'z'];
  234.  
  235.   For I := 1 to Length(S) do
  236.     If S[I] In lcase then
  237.       S[I] := Char(Ord(S[I]) - 32);
  238.   Upper := S;
  239. End;
  240.  
  241. {35**************************************************************************}
  242. Function Lower (S : Long_String)    {* Convert string S to lowercase        *}
  243.                : Long_String;       {* Return lowercase string              *}
  244.                                     {****************************************}
  245. Var
  246.   I : Integer;
  247.   ucase : Set of Char;
  248.  
  249. Begin
  250.   ucase := ['A'..'Z'];
  251.  
  252. For I := 1 to Length(S) do
  253.   If S[I] in ucase then
  254.     S[I] := Char(Ord(S[I]) + 32);
  255. lower := S;
  256. End;
  257.  
  258. {8***************************************************************************}
  259. Procedure Click;                       {* Makes a clicking noise            *
  260.                                         *************************************}
  261. var f,n : integer;
  262.  
  263. Begin
  264.   Sound(2000);
  265.   Delay(5);
  266.   NoSound;
  267. End;
  268.  
  269. {9***************************************************************************}
  270. Procedure Alert(Message : Long_String);{* This routine prints MESSAGE to the*}
  271.                                        {* screen and makes an obnoxious     *}
  272. Var                                    {* noise for about 1 second          *}
  273.   I : Integer;                         {*************************************}
  274.   i1,i2,i3,i4 : integer;
  275.  
  276.  
  277. begin
  278.   write(Message);
  279.   for i4 := 1 to 10 do
  280.     begin
  281.     i2 := 250 + i4 * 25;
  282.     for i3 := 1 to 2 do
  283.       begin
  284.       for i1 := 1 to 30 - i3 * 2 do
  285.         begin
  286.         sound(i1 + i2 + i3 * 2);
  287.         delay(2);
  288.         end;
  289.       delay(5);
  290.       i2 := i2 + 30;
  291.       end;
  292.     nosound;
  293.     end;
  294. end;
  295.  
  296. {21**************************************************************************}
  297. Procedure Clear_Window;          {* Clear the Active window                 *}
  298.                                  {*******************************************}
  299. Var
  300.   I : Integer;
  301.  
  302. Begin
  303. For I := 1 to Lower_Right_Y - Upper_Left_Y + 1 do
  304.   Begin
  305.   GotoXY(1,I);
  306.   ClrEol;
  307.   End;
  308. End;
  309.  
  310. {10**************************************************************************}
  311. Procedure Beep(N : Integer);    {*  This routine sounds a tone of frequency *}
  312.                                 {*  N for approximately 100 ms              *}
  313. Begin                           {********************************************}
  314.   Sound(n);
  315.   Delay(100);
  316.   NoSound;
  317. End;
  318.  
  319. {28**************************************************************************}
  320. Procedure Push_Screen;                {* This routine stores the current    *}
  321.                                       {* screen into a temporary storage    *}
  322.                                       {* area                               *}
  323.                                       {**************************************}
  324. Var
  325.   Temp   : Video_Ptr;
  326.   i,j,k  : integer;
  327.  
  328. Begin
  329.   If (MaxAvail < 0) or (MaxAvail > 4096) then
  330.     Begin
  331.     If Screen = Nil then
  332.       Screen := Ptr($B000,0);
  333.     new(Temp);
  334.     temp^.x1 := 1;
  335.     temp^.y1 := 1;
  336.     temp^.x2 := 80;
  337.     temp^.y2 := 25;
  338.     getmem(temp^.screen_store,4000);
  339.     Temp^.Next_Screen := Screen_Stack;
  340.     k := 1;
  341.     for i := 1 to 25 do
  342.       for j := 1 to 80 do
  343.         begin
  344.         temp^.screen_store^[k] := screen^[i][j];
  345.         inc(k);
  346.         end;
  347.     Screen_Stack := Temp;
  348.     End
  349.   Else
  350.     Begin
  351.     Alert('Insufficient Memory - You are being dumped');
  352.     Halt;
  353.     End;
  354. End;
  355.  
  356. {29**************************************************************************}
  357. Procedure Pop_Screen;                 {* This routine Pops a screen from the*}
  358.                                       {* Screen Stack                       *}
  359.                                       {**************************************}
  360. Var
  361.   Temp   : Video_Ptr;
  362.   i,j,k  : integer;
  363.  
  364. Begin
  365.   If Screen = nil then
  366.     Screen := Ptr($B000,0);
  367.  
  368.   k := 1;
  369.   for i := screen_stack^.y1 to screen_stack^.y2 do
  370.     for j := screen_stack^.x1 to screen_stack^.x2 do
  371.       begin
  372.       screen^[i][j] := screen_stack^.screen_store^[k];
  373.       inc(k);
  374.       end;
  375.  
  376.   Temp := Screen_Stack;
  377.   Screen_Stack := Screen_Stack^.Next_Screen;
  378.   freemem(Temp^.screen_store,
  379.     ((temp^.x2 - temp^.x1 + 1) * (temp^.y2 - temp^.y1 + 1)) * 2);
  380.   dispose(temp);
  381. End;
  382.  
  383. {43**************************************************************************}
  384. Procedure Marquee                    {* Draws a marquee in center screen    *}
  385.                  (Str : Long_String);{* Around the input parameter          *}
  386.                                      {***************************************}
  387.  
  388. Const
  389.   OnChr = #1;
  390.   OffChr = #2;
  391.  
  392. Var
  393.   I,J,K : Integer;
  394.   X,Y   : Integer;
  395.   Astrsk : Array[1..4] of Record
  396.                             X,Y : Integer;
  397.                             OldX,OldY : Integer;
  398.                             XI,YI     : Integer;
  399.                           End;
  400.  
  401. Begin
  402.   Window(1,1,80,25);
  403.   Push_Screen;
  404.   ClrScr;
  405.   X := 40 - Length(Str) Div 2 - 2;
  406.   For I := 10 to 14 do
  407.     Begin
  408.     Screen^[I][X].Ch := OnChr;
  409.     Screen^[I][X].Attrib := 7;
  410.     Screen^[I][X + Length(Str) + 3].Ch := OnChr;
  411.     Screen^[I][X + Length(Str) + 3].Attrib := 7;
  412.     End;
  413.   For I := X to X + Length(Str) + 3 do
  414.     Begin
  415.     Screen^[10][I].Ch := OnChr;
  416.     Screen^[14][I].Ch := OnChr;
  417.     Screen^[10][I].Attrib := 7;
  418.     Screen^[14][I].Attrib := 7;
  419.     End;
  420.   GotoXY(X+2,12);
  421.   HighVideo;
  422.   Write(Str);
  423.   LowVideo;
  424.  
  425.   Astrsk[1].X := 40;
  426.   Astrsk[1].Y := 10;
  427.   Astrsk[1].XI := 1;
  428.   Astrsk[1].YI := 0;
  429.   Astrsk[2].X := X;
  430.   Astrsk[2].Y := 12;
  431.   Astrsk[2].XI := 0;
  432.   Astrsk[2].YI := -1;
  433.   Astrsk[3].X := X + Length(Str) + 3;
  434.   Astrsk[3].Y := 12;
  435.   Astrsk[3].XI := 0;
  436.   Astrsk[3].YI := 1;
  437.   Astrsk[4].X := 40;
  438.   Astrsk[4].Y := 14;
  439.   Astrsk[4].XI := -1;
  440.   Astrsk[4].YI := 0;
  441.   Astrsk[4].OldX := Astrsk[1].X;
  442.   Astrsk[4].OldY := Astrsk[1].Y;
  443.   Astrsk[3].OldX := Astrsk[2].X;
  444.   Astrsk[3].OldY := Astrsk[2].Y;
  445.   Astrsk[2].OldX := Astrsk[3].X;
  446.   Astrsk[2].OldY := Astrsk[3].Y;
  447.   Astrsk[1].OldX := Astrsk[4].X;
  448.   Astrsk[1].OldY := Astrsk[4].Y;
  449.   K := 1;
  450.  
  451.   Repeat
  452.     If K > 4 Then
  453.       K := 1;
  454.  
  455.     J := Astrsk[K].Y;
  456.     I := Astrsk[K].X;
  457.  
  458.     If Screen = Ptr($B800,0) then
  459.       Repeat Until (Port[$3DA] And 1) = 1
  460.     Else
  461.       Repeat Until (Port[$3BA] And 1) = 1;
  462.  
  463.     Screen^[J][I].Ch := OffChr;
  464.     Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Ch := OnChr;
  465.     Screen^[J][I].Attrib := 15;
  466.     Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Attrib := 7;
  467.  
  468.     Astrsk[K].OldX := Astrsk[K].X;
  469.     Astrsk[K].OldY := Astrsk[K].Y;
  470.  
  471.     I := I + Astrsk[K].XI;
  472.     J := J + Astrsk[K].YI;
  473.  
  474.     If I > (X + Length(Str) + 3) then
  475.       Begin
  476.       I := I - Astrsk[K].XI;
  477.       Astrsk[K].XI := 0;
  478.       Astrsk[K].YI := 1;
  479.       End;
  480.  
  481.     If J > 14 then
  482.       Begin
  483.       J := J - Astrsk[K].YI;
  484.       Astrsk[K].YI := 0;
  485.       Astrsk[K].XI := -1;
  486.       End;
  487.     If I < X then
  488.       Begin
  489.       I := I - Astrsk[K].XI;
  490.       Astrsk[K].XI := 0;
  491.       Astrsk[K].YI := -1;
  492.       End;
  493.     If J < 10 then
  494.       Begin
  495.       J := J - Astrsk[K].YI;
  496.       Astrsk[K].YI := 0;
  497.       Astrsk[K].XI := 1;
  498.       End;
  499.  
  500.     Astrsk[K].Y := J;
  501.     Astrsk[K].X := I;
  502.     Inc(K);
  503.  
  504.   Until KeyPressed;
  505.   Wait;
  506.   Pop_Screen;
  507. End;
  508.  
  509. {44**************************************************************************}
  510. Procedure Help;                      {* This routine reads a screen from the*}
  511.                                      {* Screen file and displays it         *}
  512. Begin                                {***************************************}
  513.   Push_Screen;
  514.   {$I-}
  515.   Seek(ScreenFile,HelpContext);
  516.   {$I+}
  517.   If IOResult = 0 Then
  518.     Begin
  519.     {$I-}
  520.     Read(ScreenFile,ScreenBuffer);
  521.     {$I+}
  522.     Screen^ := ScreenBuffer;
  523.     If IOResult <> 0 Then
  524.       Marquee('Sorry, I''m helpless in this situation')
  525.     Else
  526.       Wait;
  527.     End
  528.   Else
  529.     Marquee('Sorry, wish I could help you.');
  530.   Pop_Screen;
  531. End;
  532.  
  533. {11**************************************************************************}
  534. Function Replicate (                          {* Repeat a character         *}
  535.                      Count : Integer;         {* Number of Repititions      *}
  536.                      Ascii : Char             {* Character to be repeated   *}
  537.                     )      : Long_String;     {* String containing repeated *}
  538.                                               {* character                  *
  539.  * This function takes the character in 'Ascii', repeats it 'Count' times   *
  540.  * and returns the resulting string as a 'Long_String'                      *
  541.  ****************************************************************************}
  542.  
  543. Var
  544.   Temp : Long_String;  {Used to hold the incomplete result}
  545.   I    : Byte;         {For Counter}
  546.  
  547. Begin
  548.   Temp := '';
  549.   For I := 1 to Count do
  550.     Temp := Temp + Ascii;
  551.   Replicate := Temp;
  552. End; {Replicate}
  553.  
  554. {12*************************************************************************}
  555. Function Left (                       {* Left Justifies a string in a      *}
  556.                 Str : Long_String;    {* field of spaces                   *}
  557.                 Width : Integer       {*************************************}
  558.               ) : Long_String;
  559.  
  560. Begin
  561.   If Length(Str) > Width then
  562.     Left := Copy(Str,1,Width)
  563.   Else
  564.     Left := Str + Replicate(Width - Length(Str),' ');
  565. End;
  566.  
  567. {13**************************************************************************}
  568. Function Center (                              {* Centers a string in field *}
  569.                   Field_Width   : Byte;        {* Width of field for center *}
  570.                   Center_String : Long_String  {* String to Center          *}
  571.                 )               : Long_String; {* Return the string         *}
  572. {************************************************                           *
  573.  * This functions takes the string 'Center_String' and centers it in a      *
  574.  * field 'Field_Width' Spaces long.  It returns a 'Long_String' with a      *
  575.  * length equal to 'Field_Width'.  If the 'Center_String' is longer than    *
  576.  * field width, it is truncated on the right end and is not centered.       *
  577.  ****************************************************************************}
  578.  
  579. Var
  580.   Temp   : Long_String;
  581.   Middle : Byte;
  582.  
  583. Begin
  584.   Middle := Field_Width div 2;
  585.   If Length(Center_String) > Field_Width then
  586.     Center := Copy(Center_String,1,Field_Width) {Truncate and return}
  587.   Else
  588.     Begin
  589.     Temp := Replicate(Middle - (Length(Center_String) div 2),' ') +
  590.             Center_String +
  591.             Replicate(Middle - (Length(Center_String) div 2) + 1,' ');
  592.     Center := Copy(Temp, 1, Field_Width)  {Truncate to Field_Width Characters}
  593.     End {Else}
  594.  End; {Center}
  595.  
  596. {39*************************************************************************}
  597. Function Power(X : Real; Y : Integer):   {* This function raises X to the  *}
  598.                Real;                     {* Yth power                      *}
  599.                                          {**********************************}
  600. Var
  601.   I : Integer;
  602.   N : Real;
  603.  
  604. Begin
  605.   N := 1.0;
  606.   For I := 1 To Y do
  607.     N := N * X;
  608.   Power := N;
  609. End; {Power}
  610.  
  611. {14*************************************************************************}
  612. Function  Get_Payment_Amount (Loan_Amount :   Real;
  613.                               Interest_Rate : Real;
  614.                               Amort_Over    : Real
  615.                              )              : Real;
  616.  
  617. VAR
  618.  
  619.   Monthly_Interest_Rate   :  Real;
  620.   Number_of_Payments      :  Integer;
  621.  
  622. BEGIN
  623.  
  624.   Monthly_Interest_Rate  :=  (Interest_Rate / 100.0) / 12.0;
  625.   Number_of_Payments  := Trunc (Amort_Over * 12);
  626.   Get_Payment_Amount := Loan_Amount *
  627.     (1 / ((1 - 1 / Power((1 + Monthly_Interest_Rate),Number_Of_Payments))/
  628.     Monthly_Interest_Rate));
  629.  
  630. END;
  631.  
  632. {15**************************************************************************}
  633. Procedure Write_Neatly (                 {* Routine to write numbers        *}
  634.                    var OutFile  : Text;  {* output file                     *}
  635.                        Number   : Real;  {* Number to be written            *}
  636.                        Width    : Byte;  {* Width of write area             *}
  637.                        Max_Dec  : Byte   {* Number of decimal places        *}
  638.                        );                {* This routine takes NUMBER, and  *}
  639.                                          {* formats it with commas and      *}
  640.                                          {* truncates to MAX_DEC decimal    *}
  641.                                          {* places.  If NUMBER is to big to *}
  642.                                          {* fit in WIDTH, then a row of     *}
  643.                                          {* asterisks WIDTH long is output  *}
  644.                                          {***********************************}
  645. Const
  646.   Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
  647.  
  648. Var
  649.   Field : Long_String;
  650.   Point : Integer;
  651.   I,J   : Integer;       {Spares for counters}
  652.  
  653. Begin
  654.   For I := 1 to Max_Dec do
  655.     Number := Number * 10;
  656.   Number := Number + 0.6;
  657.   For I := 1 to Max_Dec do
  658.     Number := Number / 10;
  659.   Str(Number:0:20,Field);  {Convert the input to a string}
  660.   I := 1;
  661.  
  662.   I := Pos('.',Field);  {Where's the Decimal!}
  663.  
  664.   If I = 0 then
  665.     Begin
  666.     Field := Field + '.';     {If no decimal, then add one}
  667.     Point := Length(Field);
  668.     End
  669.   Else
  670.     Point := I;
  671.  
  672.   I := Point - 3;  {Get the Point?}
  673.  
  674.   While I > 1 do             {put in commas, start at the back and work }
  675.     Begin                    {to the front}
  676.     Insert(',',Field,I);
  677.     I := I - 3
  678.     End;
  679.  
  680.   I := Pos('.',Field) - 1;    {Find that pesky decimal}
  681.   J := 0;
  682.  
  683.   While J <= Max_Dec do
  684.     Begin
  685.     I := I + 1;                  {Pad to Max_Dec with zeros}
  686.     If I >= Length(Field) then
  687.       Field := Field + '0';
  688.     J := J + 1;
  689.     End;
  690.  
  691.   Field := Copy(Field,1,I);      {Clean it up a little and elimate trailers}
  692.  
  693.   If Max_Dec = 0 then
  694.     Field := Copy(Field,1,I - 1); {Truncate to integer if necessary}
  695.  
  696.   If (Length(Field) > Width) and (Width > 0) then
  697.     Write(Replicate(Width,'*'))  {Too Big! tell with asterisks}
  698.   Else
  699.     Write(OutFile,Field:Width);  {all that for this}
  700.  
  701. End;
  702.  
  703. {16**************************************************************************}
  704. Function Get_Str (                          {* Get a string with editing    *}
  705.              Var In_Str      : Long_String; {* String to be edited          *}
  706.                  Buffer_Len  : Integer;     {* Its length                   *}
  707.                  Start_X     : Integer;     {* Column to start in           *}
  708.                  Y           : Integer;     {* Row for input                *}
  709.                  Force_Case  : Boolean      {* Force Input to Upper case    *}
  710.                  )           : Char;        {* Return terminating Character *}
  711.                                             {*                              *}
  712.                                             {* This is a fairly versatile   *}
  713.                                             {* string input and editing     *}
  714.                                             {* routine.  It takes IN_STRING *}
  715.                                             {* displays it at START_X,ROW   *}
  716.                                             {* allows the user to edit the  *}
  717.                                             {* string using WordStar(tm)    *}
  718.                                             {* commands.  It returns the    *}
  719.                                             {* character used to terminate  *}
  720.                                             {* input.  By setting FORCE_CASE*}
  721.                                             {* true, all input is forced to *}
  722.                                             {* upper case                   *}
  723.                                             {********************************}
  724. Const
  725.   KeyClick = True;
  726.  
  727. Var
  728.   Insert_Mode  : Boolean;
  729.   Done         : Boolean;
  730.   Current_Char : Char;
  731.   X            : Byte;
  732.   Escape       : Boolean;
  733.   Current      : Char;
  734.   in_string    : Long_String;
  735.  
  736. Begin
  737.   Done         := False;        { **                              }
  738.   Insert_Mode  := False;        {  * Initialize starting variables}
  739.   GotoXY(Start_X,Y);            {  *                              }
  740.   X := Start_X;                 { **                              }
  741.   Write(Replicate(Buffer_Len,'_'));
  742.   In_String := in_str;
  743.   GotoXY(X,Y);
  744.   Write (In_String);            {Write the initial value of the string}
  745.   GotoXY(X,Y);
  746.  
  747.   Repeat                                 {Start main edit/input loop}
  748.  
  749.     If (X - Start_X) = Buffer_Len then
  750.        Current_Char := ^M                {Terminate input if buffer is full}
  751.     Else
  752.        Read(Kbd,Current_Char);           {Get a character}
  753.  
  754.     If Force_Case then
  755.       Current_Char := UpCase(Current_Char); {force case if necessary}
  756.  
  757.     Repeat
  758.       Escape := False;
  759.       Case Current_Char of        {Act on the current input}
  760.  
  761.         ^[        : If KeyPressed then
  762.                       Begin
  763.                       Read(Kbd,Current_Char);
  764.                       Escape := True;
  765.                       Case Current_Char of           {Translate escape codes to}
  766.                         'H' : Current_Char := ^E;    {WordStar command codes   }
  767.                         'P' : Current_Char := ^X;
  768.                         'K' : Current_Char := ^S;
  769.                         'M' : Current_Char := ^D;
  770.                         'S' : Current_Char := ^G;
  771.                         'R' : Current_Char := ^V;
  772.                         '<' : Current_Char := ^R;
  773.                         's' : Current_Char := ^A;
  774.                         't' : Current_Char := ^F;
  775.                         ';' : Begin
  776.                               Help;
  777.                               Current_Char := ^@;
  778.                               End;
  779.                         'D' : Begin                  {Special Terminator}
  780.                               Done := True;
  781.                               Escape := False;
  782.                               End;
  783.                         'I' : Begin
  784.                               Done := True;
  785.                               Escape := False;
  786.                               End;
  787.                         'Q' : Begin
  788.                               Done := True;
  789.                               Escape := False;
  790.                               End;
  791.                         'O' : Begin
  792.                               Done := True;
  793.                               Escape := False;
  794.                               End;
  795.                         'G' : Begin
  796.                               Done := True;
  797.                               Escape := False;
  798.                               End;
  799.                       End; {Case}
  800.                       End; {^[}
  801.         ^E        : Done := True;                  {**               }
  802.                                                    { ** All finished }
  803.         ^X        : Done := True;                  {**               }
  804.         ^F        : x := start_x + length(in_string);
  805.         ^A        : x := start_x;
  806.         ^R        : Begin
  807.                     In_string := in_str;
  808.                     Gotoxy(start_x,y);
  809.                     write(replicate(Buffer_len,'_'));
  810.                     GotoXY(Start_X,Y);
  811.                     Write(in_string);
  812.                     End;
  813.  
  814.         ^V        : Insert_Mode := Insert_Mode XOR True; {toggle insert}
  815.  
  816.         ^S        : If X > Start_X then    {non destructive backspace}
  817.                        X := X - 1;
  818.  
  819.         ^H,#127   : If X > Start_X then    {destructive backspace}
  820.                        Begin
  821.                        Delete(In_String, X - Start_X, 1);
  822.                        GotoXY(Start_X,Y);
  823.                        Write(In_String + '_');
  824.                        X := X - 1;
  825.                        End;
  826.  
  827.         ^D        : If (X - Start_X) < Buffer_Len then  {forward 1 character}
  828.                       If (X - Start_X) < Length(In_String) Then
  829.                         X := X + 1;
  830.  
  831.         ^G        : Begin
  832.                     Delete(In_String, X - Start_X + 1,1); {delete character}
  833.                     GotoXY(Start_X,Y);                    {under the cursor}
  834.                     Write(In_String + '_');
  835.                     End;
  836.  
  837.         ^M        : Done := True;         {**}
  838.                                           { *** All Done}
  839.         ^J        : Done := True;         {**}
  840.  
  841.         ' '..'~'  : If (X - Start_X) >= Length(In_String) Then
  842.                       Begin
  843.                       In_String := In_String + Current_Char;
  844.                       GotoXY(X,Y);
  845.                       Write(Current_Char);
  846.                       If (X - Start_X) < Buffer_Len then
  847.                         X := X + 1;
  848.                       End
  849.  
  850.                     Else
  851.  
  852.                       If Insert_Mode then   {Just a run of the mill character}
  853.                         Begin               {Insert Mode}
  854.                         Insert(Current_Char,In_String, X - Start_X + 1);
  855.                         In_String := Copy(In_String,1,Buffer_Len);
  856.                         GotoXY(Start_X,Y);
  857.                         Write(In_String);
  858.  
  859.                         If (X - Start_X) < Buffer_Len then
  860.                           X := X + 1;
  861.                         GotoXY(X,Y);
  862.                         End
  863.  
  864.                       Else
  865.  
  866.                         Begin              {OverWrite Mode}
  867.                         In_String[X - Start_X + 1] := Current_Char;
  868.                         GotoXY(X,Y);
  869.                         Write(Current_Char);
  870.                         If (X - Start_X) < Buffer_Len then
  871.                           X := X + 1;
  872.                         End;
  873.  
  874.         Else
  875.       End; {Case}
  876.     Until Not Escape;
  877.     GotoXY(X,Y);
  878.     If KeyClick Then
  879.       Click;
  880.   Until Done;
  881.   Get_Str := Current_Char;               {Return the terminator}
  882.   In_str := In_string;
  883. End;
  884.  
  885. {17**************************************************************************}
  886. Function Get_Num  (                   {* This routine gets number from user *}
  887.               var Value     : Real;   {* Current Value and Returned Value   *}
  888.                   Decimals  : Integer;{* Number of Decimal Places           *}
  889.                   Min_Value : Real;   {* Minimum Value                      *}
  890.                   Max_Value : Real;   {* Maximum Value                      *}
  891.                   X         : Byte;   {* Column                             *}
  892.                   Y         : Byte    {* Row                                *}
  893.                   )         : Char;   {* Terminator                         *}
  894.                                       {*                                    *}
  895.                                       {* This routine does basically the    *}
  896.                                       {* thing as Get_Str only for numbers  *}
  897.                                       {* There are more options however.    *}
  898.                                       {* Basically Min and Max Value allow  *}
  899.                                       {* to specify the range of acceptable *}
  900.                                       {* values and DECIMALS allows you to  *}
  901.                                       {* specify the number of decimal      *}
  902.                                       {* places desired                     *}
  903.                                       {**************************************}
  904.  
  905. Const
  906.   Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
  907.  
  908. Var
  909.   I1,I2  : Integer;
  910.   S1     : Long_String;
  911.   S2     : Long_String;
  912.   S3     : Long_String;
  913.   Inchar : Char;
  914.  
  915. Begin
  916.   Str(Value:1:Decimals,S1);       {Convert to a string}
  917.   Str(Max_Value:1:Decimals,S3);   {find out how long a string max val is}
  918.  
  919.   Repeat                 {Main Loop}
  920.     S2 := '';
  921.  
  922.     Inchar := Get_Str(S1,Length(S3),X,Y,False); {Get_Str does the }
  923.                                                            {work}
  924.     For I2 := 1 to Length(S1) do     {Strip out non digits}
  925.       If S1[I2] in Valid_Digits then
  926.         S2 := S2 + S1[I2];
  927.  
  928.     Val(S2,Value,I1);                 {Find out its value}
  929.  
  930.   Until (Value >= Min_Value) and (Value <= Max_Value) and (I1 = 0); {do it }
  931.                                                            {until its right}
  932.  
  933.   GotoXY(X,Y);
  934.  
  935.   Write_Neatly(Output,Value,Length(S3),Decimals); {print the result}
  936.  
  937.   Get_Num := Inchar;  {Assign the terminator}
  938.  
  939. end;
  940.  
  941. {18**************************************************************************}
  942. procedure Frame(                      {* Frame the section of screen within *}
  943.                 UpperLeftX,           {* these bounds                       *}
  944.                 UpperLeftY,           {**************************************}
  945.                 LowerRightX,
  946.                 LowerRightY: Integer);
  947.   var
  948.     i: Integer;
  949.  
  950. begin
  951.   GotoXY(UpperLeftX,UpperLeftY);
  952.   Write(Chr(218));
  953.   GotoXY(UpperLeftX,LowerRightY);
  954.   Write(Chr(192));
  955.   GotoXY(LowerRightX,UpperLeftY);
  956.   Write(Chr(191));
  957.   GotoXY(LowerRightX,LowerRightY);
  958.   Write(Chr(217));
  959.   For I := UpperLeftX + 1 to LowerRightX - 1 do
  960.     Begin
  961.     GotoXY(I,UpperLeftY);
  962.     Write(Chr(196));
  963.     GotoXY(I,LowerRightY);
  964.     Write(Chr(196));
  965.     End;
  966.   For I := UpperLeftY + 1 to LowerRightY - 1 do
  967.     Begin
  968.     GotoXY(UpperLeftX,I);
  969.     Write(Chr(179));
  970.     GotoXY(LowerRightX,I);
  971.     Write(Chr(179));
  972.     End;
  973. end;  { Frame }
  974.  
  975. {19***************************************************************************}
  976. procedure UnFrame(                      {* This routine does the opposite of *}
  977.                   UpperLeftX,           {* frame                             *}
  978.                   UpperLeftY,           {*************************************}
  979.                   LowerRightX,
  980.                   LowerRightY: Integer);
  981.  
  982. var
  983.   i: Integer;
  984. begin
  985.   GotoXY(UpperLeftX, UpperLeftY);
  986.   Write(' ');
  987.  
  988.   for i:=UpperLeftX+1 to LowerRightX-1 do
  989.     Write(' ');
  990.  
  991.   Write(' ');
  992.  
  993.   for i:=UpperLeftY+1 to LowerRightY-1 do
  994.     begin
  995.     GotoXY(UpperLeftX , i);
  996.     Write(' ');
  997.     GotoXY(LowerRightX, i);
  998.     Write(' ');
  999.     end;
  1000.  
  1001.     GotoXY(UpperLeftX, LowerRightY);
  1002.     Write(' ');
  1003.  
  1004.     for i:=UpperLeftX+1 to LowerRightX-1 do
  1005.       Write(' ');
  1006.  
  1007.     Write(' ');
  1008. end;  {UnFrame }
  1009.  
  1010. {****************************************************************************}
  1011. Function Menu (                               {* Display a Menu             *}
  1012.                 Item_List  : Menu_Selections; {* List of Options on Menu    *}
  1013.                                               {* Last Item must be Null     *}
  1014.                                               {* String for proper operation*}
  1015.                                               {* No more than 14 items per  *}
  1016.                 Menu_X     : Integer;         {* X Location of Menu         *}
  1017.                                               {* If Menu_X = 0 then the     *}
  1018.                                               {* Menu is centered on the    *}
  1019.                                               {* Screen                     *}
  1020.                 Menu_Y     : Integer;         {* Y Location of Menu         *}
  1021.                 Menu_Title : Menu_Item;       {* Title of Menu              *}
  1022.                 Title_X    : Integer;         {* X Location of Title        *}
  1023.                                               {* If Title_X = 0 then the    *}
  1024.                                               {* Title is centered on the   *}
  1025.                                               {* screen                     *}
  1026.                 Title_Y    : Integer;         {* Y Location of Title        *}
  1027.                 Default    : Integer          {* Default Selection          *}
  1028.               )            : Integer;         {* Return the index of the    *}
  1029.                                               {* item selected by the user  *}
  1030.                                               {*                            *}
  1031. {***********************************************                            *
  1032. * This Routine Displays a Menu on the screen at the location specified by   *
  1033. * Menu_X and Menu_Y.  The Menu Title is displayed in Reverse Video at the   *
  1034. * Location specified by Title_X and Title_Y.  The User selects an item from *
  1035. * the menu by using <CTRL>-E to move a reverse video cursor bar up and      *
  1036. * <CTRL>-X to move it down.  After the cursor is on the item desired by the *
  1037. * user, he must press return.  At this point the routine returns the item   *
  1038. * number of the selection.                                                  *
  1039. *****************************************************************************}
  1040.  
  1041. Const
  1042.   CR = #13;
  1043.   Up = #5;
  1044.   Dn = #24;
  1045.  
  1046. Var
  1047.   Inchar : char;
  1048.   Menu_Pointer : 1..15;
  1049.   Menu_Length : 1..15;
  1050.   Last : Integer;
  1051.   Width : Integer;
  1052.   Len   : Integer;
  1053.   X1,X2,Y1,Y2 : Integer;
  1054.   I,j,k   : integer;
  1055.   instr : long_string;
  1056.  
  1057. Begin {Menu}
  1058.  
  1059.   instr := '';
  1060.  
  1061.   Width := Lower_Right_X - Upper_Left_X + 1;   {Calculate Window Size}
  1062.   Len   := Lower_Right_Y - Upper_Left_Y + 1;
  1063.  
  1064.   If Title_X <> 0 then       {position for the title}
  1065.     GotoXY(Title_X,Title_Y)
  1066.   Else
  1067.     GotoXY(1,Title_Y);
  1068.  
  1069.   RvsOn;
  1070.  
  1071.   If Title_X = 0 Then                 {Write the title}
  1072.     Write (Center(Width,Menu_Title))
  1073.   Else
  1074.     Write(Menu_Title);
  1075.  
  1076.   RvsOff;
  1077.  
  1078.   If Width > 38 then        {If there is enough room, write out instructions}
  1079.     Begin                   {otherwise, they is out a luck}
  1080.     Frame(1,Len-3,Width-1,Len);
  1081.     GotoXY((Width div 2) - 6,Len-3);
  1082.     Write(#17);
  1083.     RvsOn;
  1084.     Write('Instructions');
  1085.     RvsOff;
  1086.     Write(#16);
  1087.     TextColor(15);
  1088.     GotoXY(2,Len-2);
  1089.     Write(Center(Width-3,'Use '+#24+' and '+#25+' to Highlight a Selection'));
  1090.     GotoXY(2,Len-1);
  1091.     Write(Center(Width-3,' And '+#17+'DY to make the Selection'));
  1092.     TextColor(7);
  1093.     End;
  1094.  
  1095.   Inchar := ' ';               {Initialize variables}
  1096.   Menu_Pointer := 1;
  1097.  
  1098.   {Display the actual menu selections and determine how many selections
  1099.    are available}
  1100.  
  1101.   While (Menu_pointer <=15) and (length(Item_list[Menu_pointer]) > 0) do
  1102.  
  1103.     Begin
  1104.     If Menu_X <> 0 then
  1105.       Begin
  1106.       GotoXY(Menu_X,Menu_Y - 1 + Menu_Pointer);
  1107.       Write(Item_List[Menu_Pointer])
  1108.       End {If}
  1109.     Else
  1110.       Begin
  1111.       GotoXY(1,Menu_Y - 1 + Menu_Pointer);
  1112.       Write(Center(Width-1,Item_List[Menu_Pointer]))
  1113.       End; {Else}
  1114.     Menu_Pointer := Menu_Pointer + 1;
  1115.     End;  {While}
  1116.  
  1117.   Menu_Length := Menu_Pointer - 1;
  1118.   Menu_Pointer := Default;
  1119.  
  1120.   While inchar <> CR do          {Main loop}
  1121.  
  1122.     Begin
  1123.     If Menu_X <> 0 then
  1124.       Begin
  1125.       GotoXY(Menu_X,Menu_Pointer - 1 + Menu_Y); {Highlight the current menu}
  1126.       RvsOn;                                    {item}
  1127.       Write(Item_List[Menu_Pointer]);
  1128.       RvsOff;
  1129.       End {If}
  1130.     Else
  1131.       Begin
  1132.       GotoXY(1,Menu_Pointer - 1 + Menu_Y);
  1133.       RvsOn;
  1134.       Write(Center(Width-1,Item_List[Menu_Pointer]));
  1135.       RvsOff;
  1136.       End; {Else}
  1137.  
  1138.     Read(Kbd,Inchar);    {get a character from the user}
  1139.     Click;
  1140.  
  1141.     Last := Menu_Pointer;
  1142.  
  1143.     If Not (Inchar in [^[,Up,Dn,Cr]) then
  1144.  
  1145.       Begin
  1146.  
  1147.       if inchar = #127 then
  1148.         instr := ''
  1149.       else
  1150.  
  1151.         if inchar = ^H then
  1152.           delete(instr,length(instr),1)
  1153.         else
  1154.           instr := instr + inchar;
  1155.  
  1156.       j := 0;
  1157.       k := 0;
  1158.  
  1159.       for i := 1 to Menu_Length do
  1160.  
  1161.         if lower(instr) = lower(copy(item_list[i],1,length(instr))) then
  1162.  
  1163.           begin
  1164.           inc(j);
  1165.  
  1166.           if k = 0 then
  1167.             k := i;
  1168.  
  1169.           end;
  1170.  
  1171.       if k <> 0 then
  1172.         menu_pointer := k;
  1173.  
  1174.       if (j = 1) or (j = 0) then
  1175.         instr := '';
  1176.  
  1177.       end;
  1178.  
  1179.     If (Inchar = ^[) and KeyPressed then   {get the escape code}
  1180.       Read(Kbd, Inchar);
  1181.  
  1182.     If Inchar = ';' Then
  1183.       Begin
  1184.       X1 := Upper_Left_X;
  1185.       Y1 := Upper_Left_Y;
  1186.       X2 := Lower_Right_X;
  1187.       Y2 := Lower_Right_Y;
  1188.       Help;
  1189.       Window(X1,Y1,X2,Y2);
  1190.       End;
  1191.  
  1192.     If (Inchar = Up) Or (Inchar = 'H') then
  1193.       Begin                                    {They hit up arrow}
  1194.       Menu_Pointer := Menu_Pointer - 1;
  1195.       If Menu_Pointer < 1 then
  1196.         Menu_Pointer := Menu_Length;
  1197.       instr := '';
  1198.       End;  {If}
  1199.  
  1200.     If (Inchar = Dn) Or (Inchar = 'P') then
  1201.       Begin                                    {They hit down arrow}
  1202.       Menu_Pointer := Menu_Pointer + 1;
  1203.       if Menu_Pointer > Menu_Length then
  1204.         Menu_Pointer := 1;
  1205.       instr := '';
  1206.       end;  {If}
  1207.  
  1208.     If Menu_X <> 0 then                        {UnHighlight the old selection}
  1209.       Begin
  1210.       GotoXY(Menu_X, Last - 1 + Menu_Y);
  1211.       Write(Item_List[Last]);
  1212.       End {If}
  1213.     Else
  1214.       Begin
  1215.       GotoXY(1, Last - 1 + Menu_Y);
  1216.       Write(Center(Width-1,Item_List[Last]));
  1217.       End; {Else}
  1218.  
  1219.     End; {While}
  1220.  
  1221.   Beep(440);                                {They made a selection, beep once}
  1222.   Menu := Menu_Pointer;                     {to confirm}
  1223.  
  1224. end; {Menu}
  1225.  
  1226. {22**************************************************************************}
  1227. Procedure Window_Frame(x1,y1,             {* Create, frame and title a      *}
  1228.                        x2,y2 : Integer;   {* window                         *}
  1229.                        Title : Menu_Item);{**********************************}
  1230.  
  1231. Var
  1232.   Center : Integer;
  1233.  
  1234. Begin
  1235.   Window(1,1,80,25);
  1236.   Frame(x1 - 1, y1 - 1,
  1237.         x2 + 1, y2 + 1);
  1238.   Center := ((x2 - x1) div 2) + x1;
  1239.   GotoXY(Center - (Length(Title) div 2)-1,y1-1);
  1240.   Write(#17);
  1241.   RvsOn;
  1242.   Write(Title);
  1243.   RvsOff;
  1244.   Write(#16);
  1245.   Window(x1,y1,x2,y2);
  1246.   Clear_Window;
  1247. End;
  1248.  
  1249. {23**************************************************************************}
  1250. Function Encrypt(Password : Long_String) {* Encrypt a string using the      *}
  1251.                 : Long_String;           {* following algorithm:            *}
  1252.                                          {*  XOR the ordinal value of each  *}
  1253.   Var                                    {* character in the string with    *}
  1254.     Temp : Long_String;                  {* that of the next character in   *}
  1255.     I : Integer;                         {* the string.  Multiply by 2 the  *}
  1256.                                          {* result and convert back to char *}
  1257.   Begin                                  {* leave the last character of the *}
  1258.     temp := '';                          {* string in plain text as the key *}
  1259.     For I := 1 to Length(Password) - 1 do{***********************************}
  1260.       temp := Temp + Chr((ord(password[i]) xor ord(password[i+1])) shl 2);
  1261.     Encrypt := Temp + Password[Length(Password)];
  1262.   End;
  1263.  
  1264. {24**************************************************************************}
  1265. Function Decrypt(Temp : Long_String)     {* Decrypt a string encrypted by   *}
  1266.                 : Long_String;           {* the preceding procedure         *}
  1267.                                          {***********************************}
  1268.   Var
  1269.     Password : Long_String;
  1270.     I : Integer;
  1271.  
  1272.   Begin
  1273.     Password := Replicate(Length(temp),' ');
  1274.     Password[Length(temp)] := Temp[Length(temp)];
  1275.     For I := Length(Temp) - 1 downto 1 do
  1276.       Password[I] := Chr((ord(temp[i]) shr 2) xor ord(password[i+1]));
  1277.     Decrypt := Password;
  1278.   End;
  1279.  
  1280. {25**************************************************************************}
  1281. Function GetChar(Var Done : Boolean) : Char;{* Get a character from the Kbd *}
  1282.                                             {********************************}
  1283. Var
  1284.   Inchar : Char;
  1285.  
  1286. Begin
  1287.   Read(Kbd,Inchar);
  1288.   Done := (Inchar = ^\);
  1289.   GetChar := Inchar;
  1290. End;
  1291.  
  1292. {27**************************************************************************}
  1293. Function Get_Pass(X,Y : Integer) : Long_String;{* This routine obtains a    *}
  1294.                                                {* password from the user    *}
  1295. Var                                            {* nothing more, nothing less*}
  1296.   Inchar : Char;                               {*****************************}
  1297.   Temp   : Long_String;
  1298.  
  1299. Begin
  1300.   GotoXY(X,Y);
  1301.   Write('Password: ');
  1302.   Temp := '';
  1303.   TextColor(0);
  1304.   TextBackGround(0);
  1305.   Inchar := Get_Str(Temp,10,X + 10,y,True);
  1306.   RvsOff;
  1307.   If Temp = Replicate(10,' ') then
  1308.     Temp := '';
  1309.   Get_Pass := Temp;
  1310. End;
  1311.  
  1312. {32**************************************************************************}
  1313. Procedure SetUp  {Set the UART for communications}
  1314.                (Portal : Integer;
  1315.                 Baud   : Integer;
  1316.                 Parity : Parity_Types;
  1317.                 Stop   : Byte;
  1318.                 Word   : Byte);
  1319.  
  1320. Begin
  1321.  
  1322.   Port[LCR + Portal] := 128;
  1323.  
  1324.   {Set Baud Rate}
  1325.   Baud := Trunc(115200.0 / Baud);
  1326.   Port[DLL + Portal] := Lo(Baud);
  1327.   Port[DLM + Portal] := Hi(Baud);
  1328.  
  1329.   {Set Parity}
  1330.   Case Parity of
  1331.     No_Parity   : Port[LCR + Portal] := Port[LCR + Portal] And Not(PEN);
  1332.     Even_Parity : Begin
  1333.                   Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
  1334.                   Port[LCR + Portal] := Port[LCR + Portal] Or EPS;
  1335.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
  1336.                   End;
  1337.     Odd_Parity  : Begin
  1338.                   Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
  1339.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(EPS);
  1340.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
  1341.                   End;
  1342.   End;
  1343.  
  1344.   {Set Stop Bits}
  1345.   Port[LCR + Portal] := Port[LCR + Portal] And (Not(STB) + (STB * (Stop - 1)));
  1346.  
  1347.   {Set Word Length}
  1348.   Port[LCR + Portal] := Port[LCR + Portal] And Not(WLS);
  1349.   Word := (Word - 5) and WLS;
  1350.   Port[LCR + Portal] := Port[LCR + Portal] or Word;
  1351.  
  1352.   Port[LCR + Portal] := Port[LCR + Portal] And 127;
  1353.  
  1354. End; {Set up}
  1355.  
  1356. {36**************************************************************************}
  1357. Procedure DosConOut(Ch : Char);      {* Write character to video display    *}
  1358.                                      {* using DOS driver                    *}
  1359. Var                                  {***************************************}
  1360.   Registers : Reg;
  1361.  
  1362. Begin
  1363.   Registers.AX := $0200;
  1364.   Registers.DX := Ord(Ch);
  1365.   MsDos(Registers);
  1366. End;
  1367.  
  1368. var
  1369.   serial_buffer : long_string;
  1370.  
  1371. {37**************************************************************************}
  1372. Procedure SerialOut(Ch : Char);      {* This routine sends a character over *}
  1373.                                      {* the rs232 using a standard BIOS call*}
  1374. Var                                  {* (INT 14)                            *}
  1375.   Registers : Reg;                   {***************************************}
  1376.  
  1377. Begin
  1378.   Registers.AX := $0100 + Ord(Ch);    {Set the registers}
  1379.   Registers.DX := Com;
  1380.   Intr($14,Registers);               {Send out the character}
  1381. End;
  1382.  
  1383. {40**************************************************************************}
  1384. Function Data : Boolean;             {* This routine returns true if the    *}
  1385.                                      {* serial port has valid data          *}
  1386. Var                                  {***************************************}
  1387.   Registers : Reg;
  1388.   portno    : integer;
  1389.  
  1390. Begin
  1391.   portno := $3fd - ($100 * Com);
  1392.   data := (port[portno] and 1) = 1;
  1393. End;
  1394.  
  1395. {38**************************************************************************}
  1396. Function SerialIn : Char;            {* This routine reads a character from *}
  1397.                                      {* the serial port if one is available *}
  1398. Var                                  {* If no character is available, the   *}
  1399.   Registers : Reg;                   {* returns a null char (^@).           *}
  1400.   ch        : char;                  {***************************************}
  1401.  
  1402. Begin
  1403.   serialin := chr(port[$3f8 - ($100 * com)]);
  1404. End;
  1405.  
  1406. {41**************************************************************************}
  1407. Procedure ColScr;                    {* Switch to Color Monitor if it is    *}
  1408.                                      {* available, otherwise leave as is    *}
  1409. Const                                {***************************************}
  1410.   VidReg : Array[0..15] of Integer =
  1411.   ($71,$50,$5A,$0A,$1F,$06,$19,$1C,$02,$07,$06,$07,$00,$00,$00,$00);
  1412.   Mode     = $3B8;
  1413.   Color    = $3B9;
  1414.   RegNum   = $3D4;
  1415.   RegVal   = $3D5;
  1416.   ColorVal = $30;
  1417.   ModeVal  = $2D;
  1418.  
  1419. Var
  1420.   I : Byte;
  1421.  
  1422. Begin
  1423. {  Port[Mode] := ModeVal;
  1424.   Port[Color] := ColorVal;
  1425.   For I := 0 to 15 do
  1426.     Begin
  1427.     Port[RegNum] := I;
  1428.     Port[RegVal] := VidReg[I];
  1429.     End;
  1430. }  Screen := Ptr($B800,0);
  1431. End;
  1432.  
  1433. {42**************************************************************************}
  1434. Procedure MonoScr;                   {* Switch to MonoChrome Monitor if     *}
  1435.                                      {* available, otherwise leave as is    *}
  1436. Const                                {***************************************}
  1437.   VidReg : Array[0..15] of Integer =
  1438.   ($61,$50,$52,$0F,$19,$06,$19,$19,$02,$0D,$0B,$0C,$00,$00,$00,$00);
  1439.  
  1440.   Mode     = $3B8;
  1441.   Color    = $3B9;
  1442.   RegNum   = $3B4;
  1443.   RegVal   = $3B5;
  1444.   ColorVal = $30;
  1445.   ModeVal  = $29;
  1446.  
  1447. Var
  1448.   I : Byte;
  1449.  
  1450. Begin
  1451.   Port[Mode] := ModeVal;
  1452.   Port[Color] := ColorVal;
  1453.   For I := 0 to 15 do
  1454.     Begin
  1455.     Port[RegNum] := I;
  1456.     Port[RegVal] := VidReg[I];
  1457.     End;
  1458.   Screen := Ptr($B000,0);
  1459. End;
  1460.  
  1461. {45**************************************************************************}
  1462. Procedure Well;
  1463.  
  1464. Var
  1465.   I,J : Integer;
  1466.  
  1467. Begin
  1468.   I := 0;
  1469.   While Not KeyPressed do
  1470.     Begin
  1471.     Click;
  1472.     Delay(250);
  1473.     If I = 100 then Write('Well?');
  1474.     Inc(I);
  1475.     End;
  1476. End;
  1477.  
  1478. {47**************************************************************************}
  1479. Procedure Siren;                     {* This is the alarm for intruder alert*}
  1480.                                      {***************************************}
  1481. var i,j : integer;
  1482.  
  1483. begin
  1484.   for j := 1 to 20 do
  1485.     begin
  1486.     for i := 200 to 2300 do
  1487.       sound(i);
  1488.     nosound;
  1489.     delay(100);
  1490.     end;
  1491. end;
  1492.  
  1493. {48**************************************************************************}
  1494. type
  1495.   typelist = (ustr,lstr,ulstr,rnum,inum,yn);
  1496.  
  1497. function getform(   var value;
  1498.                         vtype   : typelist;
  1499.                         X,Y,
  1500.                         dp,Len  : integer;
  1501.                         Lstrg   : long_string;
  1502.                         lx,ly   : integer
  1503.                               ) : char;
  1504.  
  1505. var
  1506.   realval : real absolute value;
  1507.   intval  : integer absolute value;
  1508.   strval  : long_string absolute value;
  1509.   boolval : boolean absolute value;
  1510.   mval    : real;
  1511.   tint    : integer;
  1512.   tstr    : long_string;
  1513.   tchar   : char;
  1514.  
  1515. begin
  1516.   gotoxy(lx,ly);
  1517.   highvideo;
  1518.   write(lstrg);
  1519.   case vtype of
  1520.  
  1521.     ustr  : getform := get_str(strval,len,x,y,true);
  1522.     lstr  : begin
  1523.             getform := get_str(strval,len,x,y,false);
  1524.             strval := lower(strval);
  1525.             end;
  1526.     ulstr : getform := get_str(strval,len,x,y,false);
  1527.     rnum  : begin
  1528.             val(replicate(len - dp - 1,'9'),mval,tint);
  1529.             getform := get_num(realval,dp,0,mval,x,y);
  1530.             end;
  1531.     inum  : begin
  1532.             getform := get_num(mval,0,-32767,maxint,x,y);
  1533.             intval := trunc(mval);
  1534.             end;
  1535.     yn    : begin
  1536.             gotoxy(x,y);
  1537.             if boolval then
  1538.               tstr := 'Y'
  1539.             else
  1540.               tstr := 'N';
  1541.             repeat
  1542.               tchar := get_str(tstr,1,x,y,true);
  1543.             until tstr[1] in ['Y','N'];
  1544.             boolval := tstr = 'Y';
  1545.             getform := tchar;
  1546.             end;
  1547.   end;
  1548.  
  1549.   gotoxy(lx,ly);
  1550.   lowvideo;
  1551.   write(lstrg);
  1552. end;
  1553.  
  1554. {*********************************************************************}
  1555.  
  1556. const monthmask = $000F;
  1557.       daymask = $001F;
  1558.       minutemask = $003F;
  1559.       secondmask = $001F;
  1560. type  dtstr = string[8];
  1561.  
  1562. {49*******************************************************************}
  1563.  
  1564. function getdate : dtstr;
  1565.  
  1566. var
  1567.   allregs : register;
  1568.   month, day,
  1569.   year    : string[2];
  1570.   i       : integer;
  1571.   tstr    : dtstr;
  1572.  
  1573. begin
  1574.    allregs.ax := $2A * 256;
  1575.    MsDos(allregs);
  1576.    str((allregs.dx div 256):2,month);
  1577.    str((allregs.dx mod 256):2,day);
  1578.    str((allregs.cx - 1900):2,year);
  1579.    tstr := month + '/' + day + '/' + year;
  1580.    for i := 1 to 8 do
  1581.      if tstr[i] = ' ' then
  1582.        tstr[i] := '0';
  1583.    getdate := tstr;
  1584. end;  {getdate}
  1585.  
  1586. {50*******************************************************************}
  1587.  
  1588. function gettime : dtstr;
  1589.  
  1590. var
  1591.  allregs : register;
  1592.  hour, minute,
  1593.  second  : string[2];
  1594.  i       : integer;
  1595.  tstr    : dtstr;
  1596.  
  1597. begin
  1598.    allregs.ax := $2C * 256;
  1599.    MsDos(allregs);
  1600.    str((allregs.cx div 256):2,hour);
  1601.    str((allregs.cx mod 256):2,minute);
  1602.    str((allregs.dx div 256):2,second);
  1603.    tstr := hour + ':' + minute + ':' + second;
  1604.    for i := 1 to 8 do
  1605.      if tstr[i] = ' ' then
  1606.        tstr[i] := '0';
  1607.    gettime := tstr;
  1608. end;  {gettime}
  1609.  
  1610. {51*******************************************************************}
  1611. procedure push_window(x1,y1,x2,y2 : integer);
  1612.  
  1613. var
  1614.   temp : video_ptr;
  1615.   i,j,k  : integer;
  1616.  
  1617. begin
  1618.   if screen = nil then
  1619.     screen := ptr($b000,0);
  1620.   new(Temp);
  1621.   temp^.x1 := x1;
  1622.   temp^.y1 := y1;
  1623.   temp^.x2 := x2;
  1624.   temp^.y2 := y2;
  1625.   getmem(temp^.screen_store,((x2 - x1 + 1) * (y2 - y1 + 1)) * 2);
  1626.   Temp^.Next_Screen := Screen_Stack;
  1627.   k := 1;
  1628.   for i := y1 to y2 do
  1629.     for j := x1 to x2 do
  1630.       begin
  1631.       temp^.screen_store^[k] := screen^[i][j];
  1632.       inc(k);
  1633.       end;
  1634.   Screen_Stack := Temp;
  1635. end;
  1636.  
  1637. {52*******************************}
  1638. function elapsed_time(start_time : real) : real;
  1639.  
  1640. var
  1641.   j       : integer;
  1642.   i,k,
  1643.   endtime : real;
  1644.  
  1645. begin
  1646.   val(copy(gettime,7,2),i,j);
  1647.   endtime := i * 3600.0;
  1648.   val(copy(gettime,5,2),i,j);
  1649.   endtime := endtime + (i * 60);
  1650.   val(copy(gettime,1,2),i,j);
  1651.   endtime := endtime + i;
  1652.   k := endtime - start_time;
  1653.   elapsed_time := k
  1654. end;